home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 3032.ZIP / RLIB20.ZIP / RL_PDOWN.PRG < prev    next >
Text File  |  1989-02-18  |  15KB  |  460 lines
  1. * Function..: PDOWNINIT
  2. * Author....: Richard Low
  3. * Syntax....: PDOWNINIT( row, columns, options, items, starts, prompts,;
  4. *                        promptrow, colors, altkeys, exit )
  5. *
  6. * Notes.....: Mandatory function to initialize PDOWNMENU for operation.
  7. *             Optional parameters are not required, but if you wish to skip
  8. *             an optional parameter, you must pass a dummy value.  The best
  9. *             dummy value to use is a null string '' (set up a memvar named
  10. *             dummy where dummy = '').
  11. *
  12. * Parameters: row       - NUMERIC row for top of Pull Down Menu to appear.
  13. *             columns   - ARRAY of column numbers for each top level option.
  14. *             options   - ARRAY of top level menu option choices.
  15. *             items     - ARRAY of pulled down menu items.
  16. *             starts    - ARRAY of starting element numbers.
  17. *             prompts   - Optional ARRAY corresponding menu item messages.
  18. *             promptrow - Optional NUMERIC row on which these messages appear.
  19. *             colors    - Optional ARRAY of colors to use for the top Bar and
  20. *                         pull down Box menus.
  21. *
  22. *                           color[1] - Option & message displays
  23. *                           color[2] - Menu selection bars
  24. *                           color[3] - Pull-down menu box ACTIVE color
  25. *                           color[4] - Pull-down menu box IN-ACTIVE color
  26. *                           color[5] - Pull-down menu option after selection
  27. *                           color[6] - Menu bar option after selection
  28. *
  29. *             altkeys   - Optional ARRAY of alternate select keys for each menu.
  30. *             exit      - Optional LOGICAL indicating if escape will exit menu.
  31. *
  32. * Returns...: True if initialization sucessful, False if parameters error.
  33. *
  34.  
  35. FUNCTION PDOWNINIT
  36. PARAMETERS prow, pcols, pmenus, pitems, pstarts, pprompts, promptrow,;
  37.            p_colors, paltkeys, pexit
  38.  
  39. IF PCOUNT() = 0
  40.    *-- if no parameters, release PUBLIC arrays to reclaim memory
  41.    RELEASE rl_pd, pd_counts, pd_altkeys, pd_bottoms, pd_rights
  42.    RETURN (.T.)
  43. ENDIF
  44.  
  45. *-- make sure that all the required parameters are the correct type
  46. IF TYPE('prow')   + TYPE('pcols')   + TYPE('pmenus') +;
  47.    TYPE('pitems') + TYPE('pstarts') != 'NAAAA'
  48.    RETURN (.F.)
  49. ENDIF
  50.  
  51. *-- the number of columns, top level options, starting array element
  52. *-- numbers, and menu item counts must all be the same
  53. IF .NOT. ( LEN(pcols) = LEN(pmenus) .AND. LEN(pcols) = LEN(pstarts) )
  54.    RETURN (.F.)
  55. ENDIF
  56.  
  57. *-- there must be more than one menu (get real)
  58. IF LEN(pcols) < 2
  59.    RETURN (.F.)
  60. ENDIF
  61.  
  62.  
  63. last_menu = LEN(pmenus)
  64. PUBLIC pd_counts[last_menu],  pd_altkeys[last_menu]
  65. PUBLIC pd_bottoms[last_menu], pd_rights[last_menu]
  66.  
  67.  
  68. *-- fill in menu item counts based on start numbers
  69. *-- can't start at 1 because of computational algorithm
  70. pd_counts[1] = pstarts[2] - 1
  71. FOR x = 2 TO last_menu - 1
  72.    *-- count of options in this menu equal next start number minus this start
  73.    pd_counts[x] = pstarts[x+1] - pstarts[x]
  74. NEXT x
  75. *-- number of items in last menu is equal to length of array - starting # + 1
  76. pd_counts[ last_menu ] = LEN(pitems) - pstarts[ last_menu ] + 1
  77.  
  78.  
  79. *-- copy the altkeys array if it exists
  80. IF TYPE('paltkeys') = 'A'
  81.    ACOPY( paltkeys, pd_altkeys )
  82. ELSE
  83.    *-- otherwise fill it with nulls
  84.    AFILL( pd_altkeys, '' )
  85. ENDIF
  86.  
  87. AFILL( pd_bottoms, 0 )
  88. AFILL( pd_rights,  0 )
  89.  
  90.  
  91. *-- make configuration array public
  92. PUBLIC rl_pd[15]
  93.  
  94. rl_pd[ 1] = LEN(pmenus)                             && N - number of menus (used for offset)
  95. rl_pd[ 2] = ''                                      && C - main menu direct select keys
  96. rl_pd[ 3] = IF(TYPE('pbox')='C', pbox, '┌─┐│┘─└│')  && C - boxing string
  97.  
  98. rl_pd[ 4] = SETCOLOR()                              && save incoming color
  99.  
  100. *-- use <color array> if it is an array AND it has at least 5 elements
  101. IF IF( TYPE('p_colors') = 'A', IF(LEN(p_colors) >= 5, .T., .F.) , .F. )
  102.    rl_pd[ 6] = p_colors[1]              && display color
  103.    rl_pd[ 7] = p_colors[2]              && menu bar color
  104.    rl_pd[ 8] = p_colors[3]              && active pull down menu box color
  105.    rl_pd[ 9] = p_colors[4]              && pull down menu box border after exit
  106.    rl_pd[10] = p_colors[5]              && pull down menu selected option color
  107.  
  108.    rl_pd[ 5] = p_colors[6]              && top bar menu selected option color
  109. ELSE
  110.    rl_pd[ 6] = rl_pd[4]
  111.    rl_pd[ 7] = GETPARM(2, rl_pd[4])
  112.    rl_pd[ 8] = BRIGHT(rl_pd[4])
  113.    rl_pd[ 9] = rl_pd[4]
  114.    rl_pd[10] = rl_pd[8]
  115.  
  116.    rl_pd[ 5] = rl_pd[8]
  117. ENDIF
  118.  
  119.  
  120. *-- window coordinates and buffer
  121. rl_pd[11] = prow                         && N - <maxtop> (top row for main menu)
  122. rl_pd[12] = pcols[1]                     && N - <maxleft>
  123. rl_pd[13] = 0                            && N - <maxbottom>
  124. rl_pd[14] = 0                            && N - <maxright>
  125. rl_pd[15] = ''                           && C - window to hold screen
  126.  
  127.  
  128. *-- display bar menu options and build a list of first letter pick keys
  129. *-- and store coordinates for later fast access, and determine maximum
  130. *-- bottom and right coordinates
  131.  
  132. xjunk = ''
  133. SETCOLOR(rl_pd[6])
  134. @ prow,0                                  && clear option line in that color
  135.  
  136. FOR x = 1 TO LEN(pmenus)
  137.    @ prow,pcols[x] SAY pmenus[x]
  138.    xjunk = xjunk + SUBSTR( LTRIM(pmenus[x]),1,1 )                && build list of direct pick keys
  139.    pd_bottoms[x] = prow + pd_counts[x] + 2                       && bottom coordinate for this menu
  140.    pd_rights[x]  = pcols[x] + LEN(pitems[pstarts[x]]) + 1           && right coordinate for this menu
  141.    rl_pd[13] = MAX( rl_pd[13], pd_bottoms[x] )
  142.    rl_pd[14] = MAX( rl_pd[14], pd_rights[x]  )
  143.  
  144.    *-- fill direct select strings with default first letters for each menu
  145.    yjunk = ''
  146.    FOR y = 1 TO pd_counts[x]
  147.       yjunk = yjunk + SUBSTR(LTRIM(pitems[pstarts[x]+y-1]),1,1)
  148.    NEXT y
  149.    *-- now add to list passed as parameter, if any
  150.    pd_altkeys[x] = yjunk + pd_altkeys[x]
  151.  
  152. NEXT x
  153.  
  154. *-- set color back to way it was
  155. SETCOLOR(rl_pd[4])
  156.  
  157. *-- main menu direct and alternate select keys
  158. rl_pd[2] = xjunk
  159.  
  160. *-- save screen that was painted with top menu options
  161. rl_pd[15] = SAVESCREEN(rl_pd[11],rl_pd[12],rl_pd[13],rl_pd[14])
  162.  
  163. RETURN (.T.)
  164.  
  165.  
  166.  
  167.  
  168.  
  169. *****************************************************************************
  170. * Function..: PDOWNMENU
  171. * Syntax....: PDOWNMENU( @menu, @item, menus, items, columns, starts;
  172. *                        [, prompts [, exit ] ] )
  173. *
  174. * Notes.....: Pull down menu operation AFTER initialized with PDOWNINIT(...)
  175. *             All but the last two parameters are required!  If the <prompts>
  176. *             are not used, but <exit> is, pass a dummy parameter for <prompts>
  177. *
  178. * Parameters: @menu   - pointer to NUMERIC indicating starting top menu option
  179. *             @item   - pointer to NUMERIC starting menu item (if any) 0 = stay in top
  180. *             menus   - ARRAY of top level menu option choices.
  181. *             items   - ARRAY of pulled down menu items.
  182. *             columns - ARRAY of column numbers for each top level option.
  183. *             starts  - ARRAY of starting element numbers.
  184. *             prompts - Optional ARRAY corresponding menu item messages.
  185. *             exit    - Optional LOGICAL indicating if escape will exit.
  186. *                       Default is True.
  187. *
  188. * Returns...:
  189. *
  190. *
  191. *
  192. *****************************************************************************
  193. FUNCTION PDOWNMENU
  194.  
  195. PARAMETERS pullmenu, pullitem, pmenus, pitems, pcols, pstarts, pprompts, pexit
  196.  
  197. PRIVATE fc_incolor, fc_display, fc_menubar, fc_box_on, fc_box_off,;
  198.         fc_selitem, fc_selmenu
  199.  
  200. *-- verify parameters and types
  201. IF TYPE('pullmenu') + TYPE('pullitem') + TYPE('pmenus') +;
  202.    TYPE('pitems')   + TYPE('pstarts')  + TYPE('pcols')  != 'NNAAAA'
  203.    RETURN 0
  204. ENDIF
  205.  
  206. prmts_on = IF( TYPE('pprompts') = 'A', .T.,    .F. )      && if prompts being displayed
  207. prmt_row = IF( TYPE('prmtrow')  = 'N', prmtrow, 24 )      && row for prompt messages
  208. pexit    = IF( TYPE('pexit')    = 'L', pexit,  .T. )
  209.  
  210.  
  211. *-- retrieve and store colors so they can be used by descriptive names
  212. fc_incolor = rl_pd[ 4]
  213. fc_display = rl_pd[ 6]
  214. fc_menubar = rl_pd[ 7]
  215. fc_box_on  = rl_pd[ 8]
  216. fc_box_off = rl_pd[ 9]
  217. fc_selitem = rl_pd[10]
  218. fc_selmenu = rl_pd[ 5]
  219.  
  220.  
  221. *-- first pop the screen that was saved during the initialization
  222. *-- in case the routine that calls PDOWNMENU() messed with the screen
  223. *-- since it was painted with PDOWNINIT()
  224. RESTSCREEN( rl_pd[11], rl_pd[12], rl_pd[13], rl_pd[14], rl_pd[15] )
  225.  
  226.  
  227. *-- make sure the menu and item numbers supplied are within array bounds
  228. pullmenu = IF( pullmenu < 1 .OR. pullmenu > LEN(pmenus), 1, pullmenu )
  229.  
  230.  
  231. *-- if an option is selected from a pull down, pullitem will = option number
  232. DO WHILE .T.
  233.  
  234.    *-- if we are to go back into the pulled down menu, do it
  235.    IF pullitem > 0
  236.       pullitem = PULLDOWN_2()
  237.    ELSE
  238.       *-- otherwise, stay in top level menu
  239.  
  240.       *-- display current selection in reverse video
  241.       SETCOLOR(fc_menubar)
  242.       @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  243.       SETCOLOR(fc_display)
  244.  
  245.       *-- wait for a key
  246.       f_lkey = INKEY(0)
  247.  
  248.       DO CASE
  249.  
  250.          CASE f_lkey = 4 .OR. f_lkey = 32
  251.             *-- Right Arrow or Space Bar
  252.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  253.             pullmenu = IF( pullmenu = LEN(pmenus), 1, pullmenu + 1 )
  254.  
  255.          CASE f_lkey = 19 .OR. f_lkey = 8
  256.             *-- Left Arrow or Back Space
  257.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  258.             pullmenu = IF( pullmenu = 1, LEN(pmenus), pullmenu - 1 )
  259.  
  260.          CASE f_lkey = 1
  261.             *-- Home Key
  262.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  263.             pullmenu = 1
  264.  
  265.          CASE f_lkey = 6
  266.             *-- End key
  267.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  268.             pullmenu = LEN(pmenus)
  269.  
  270.          CASE f_lkey = 13
  271.             *-- Enter key
  272.             SETCOLOR(fc_selmenu)
  273.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  274.             *-- go into pull down menu with side stepping
  275.             pullitem = PULLDOWN_2()
  276.  
  277.          CASE UPPER(CHR(f_lkey)) $ rl_pd[2]
  278.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  279.             x = 1
  280.             pullmenu = 0
  281.             DO WHILE pullmenu = 0
  282.                pullmenu = AT(UPPER(CHR(f_lkey)),SUBSTR(rl_pd[2],x,LEN(pmenus)))
  283.                x = x + LEN(pmenus)
  284.             ENDDO
  285.             SETCOLOR(fc_selmenu)
  286.             @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  287.             pullitem = PULLDOWN_2()
  288.  
  289.          CASE f_lkey = 27 .AND. pexit
  290.             *-- Escape allowed to exit
  291.             pullmenu = 0
  292.             EXIT
  293.  
  294.       ENDCASE
  295.    ENDIF
  296.  
  297.    *-- if an option was selected, exit
  298.    IF pullitem != 0
  299.       EXIT
  300.    ENDIF
  301.  
  302. ENDDO
  303.  
  304. **-- display selected option in bright color
  305. *IF pullmenu > 0 .AND. pullmenu <= LEN(pmenus)
  306. *   SETCOLOR(fc_selitem)
  307. *   @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  308. *ENDIF
  309.  
  310. **-- if messages are on, clear the message line
  311. *IF prmts_on
  312. *   @ prmt_row,0
  313. *ENDIF
  314.  
  315. *-- restore original color
  316. SETCOLOR(fc_incolor)
  317.  
  318. RETURN IF( pullmenu = 0, 0, pstarts[pullmenu] + pullitem - 1 )
  319.  
  320.  
  321.  
  322. FUNCTION PullDown_2
  323. * Syntax....: PULLDOWN_2()
  324. *
  325. *
  326.  
  327. *-- this proc displays top menu option in selected color and paints menu
  328. DO pd2_setup
  329.  
  330. DO WHILE .T.
  331.  
  332.    *-- display current selection in (selected) video
  333.    SETCOLOR(fc_menubar)
  334.    @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  335.    SETCOLOR(fc_display)
  336.  
  337.    *-- if message prompts are on, clear row and display
  338.    IF prmts_on
  339.       @ prmt_row,0
  340.       @ prmt_row,(80-LEN( pprompts[ pstarts[pullmenu]+pullitem-1 ] ))/2 ;
  341.          SAY pprompts[ pstarts[pullmenu]+pullitem-1 ]
  342.    ENDIF
  343.  
  344.    *-- wait for a key
  345.    f_lkey = INKEY(0)
  346.  
  347.    DO CASE
  348.  
  349.       CASE f_lkey = 4 .OR. f_lkey = 32
  350.          *-- Right Arrow or Space Bar
  351.          pullmenu = IF( pullmenu = LEN(pmenus), 1, pullmenu + 1 )
  352.          pullitem = 1
  353.          DO pd2_setup
  354.  
  355.       CASE f_lkey = 19 .OR. f_lkey = 8
  356.          *-- Left Arrow or Back Space
  357.          pullmenu = IF( pullmenu = 1, LEN(pmenus), pullmenu - 1 )
  358.          pullitem = 1
  359.          DO pd2_setup
  360.  
  361.       CASE f_lkey = 24
  362.          *-- Down Arrow
  363.          @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  364.          pullitem = IF( pullitem = pd_counts[pullmenu], 1, pullitem + 1 )
  365.  
  366.       CASE f_lkey = 5
  367.          *-- Up Arrow or Back Space
  368.          @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  369.          pullitem = IF( pullitem = 1, pd_counts[pullmenu], pullitem - 1 )
  370.  
  371.       CASE f_lkey = 1
  372.          *-- Home Key
  373.          @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  374.          pullitem = 1
  375.  
  376.       CASE f_lkey = 6
  377.          *-- End key
  378.          @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  379.          pullitem = pd_counts[pullmenu]
  380.  
  381.       CASE f_lkey = 13
  382.          *-- Enter key
  383.          EXIT
  384.  
  385.       CASE UPPER(CHR(f_lkey)) $ pd_altkeys[pullmenu]
  386.          @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  387.          x = 1
  388.          pullitem = 0
  389.          DO WHILE pullitem = 0
  390.             pullitem = AT(UPPER(CHR(f_lkey)),SUBSTR(pd_altkeys[pullmenu],x,pd_counts[pullmenu]))
  391.             x = x + pd_counts[pullmenu]
  392.          ENDDO
  393.          EXIT
  394.  
  395.       CASE f_lkey = 27
  396.          *-- Escape request
  397.          pullitem = 0
  398.          EXIT
  399.  
  400.    ENDCASE
  401. ENDDO
  402.  
  403.  
  404. IF pullitem = 0
  405.    *-- restore original screen and color
  406.    RESTSCREEN( rl_pd[11], rl_pd[12], rl_pd[13], rl_pd[14], rl_pd[15] )
  407. ELSE
  408.    *-- display selected option in bright color
  409.    SETCOLOR(fc_selitem)
  410.    @ rl_pd[11]+1+pullitem,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+pullitem-1 ]
  411.    SETCOLOR(fc_box_off)
  412.    @ rl_pd[11]+1, pcols[pullmenu], pd_bottoms[pullmenu], pd_rights[pullmenu] BOX '┌─┐│┘─└│'
  413. ENDIF
  414.  
  415. *-- if messages are on, clear the message line
  416. SETCOLOR(fc_display)
  417. IF prmts_on
  418.    @ prmt_row,0
  419. ENDIF
  420.  
  421. RETURN (pullitem)
  422.  
  423.  
  424.  
  425.  
  426. *******************
  427. PROCEDURE pd2_setup
  428. *******************
  429.  
  430.  
  431. *-- restore original screen underneath
  432. RESTSCREEN( rl_pd[11], rl_pd[12], rl_pd[13], rl_pd[14], rl_pd[15] )
  433.  
  434. *-- display the top bar item in selected color
  435. SETCOLOR(fc_selmenu)
  436. @ rl_pd[11],pcols[pullmenu] SAY pmenus[pullmenu]
  437.  
  438. *-- now draw the box for the menu using the maximum width of options
  439. SETCOLOR(fc_box_on)
  440. @ rl_pd[11]+1, pcols[pullmenu], pd_bottoms[pullmenu], pd_rights[pullmenu] BOX '╔═╗║╝═╚║'
  441. SETCOLOR(fc_display)
  442.  
  443. ** SCROLL( rl_pd[11]+2, pcols[pullmenu]+1, pd_bottoms[pullmenu]-1, pd_rights[pullmenu]-1, 0)
  444.  
  445. IF NEXTKEY() = 4 .OR. NEXTKEY() = 19
  446.    *-- if stomping down on arrow keys, skip this stuff
  447.    RETURN
  448. ENDIF
  449.  
  450.  
  451. *-- display options
  452. FOR x = 1 TO pd_counts[pullmenu]
  453.    @ rl_pd[11]+1+x,pcols[pullmenu]+1 SAY pitems[ pstarts[pullmenu]+x-1 ]
  454. NEXT x
  455.  
  456. *-- starting choice is always 1, if not already specified
  457. pullitem = IF( pullitem <= 0, 1, pullitem )
  458.  
  459. RETURN
  460.